home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / BBS_UTL / BBSKIT31 / HOST.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-05  |  15KB  |  564 lines
  1. {
  2.   Host.Pas
  3.  
  4.   A sample host BBS for BBSkit.
  5.  
  6.   Version 1.3, updated for BBSkit 3.0.
  7.  
  8.   Written by Steve Madsen.
  9.  
  10.   NOTE: intended to be compiled using the registered version of BBSkit.  If
  11.   you wish to recompile with a demo copy, remove the space before the $ in
  12.   the following $DEFINE.
  13. }
  14.  
  15. { $DEFINE DEMO}
  16.  
  17. {$X+,V-}
  18.  
  19. PROGRAM Host13;
  20.  
  21. {$DEFINE NOBSP}
  22.  
  23. Uses DOS, CRT, BBSkit, Comm, Protocol, Util, MTask;
  24.  
  25. Const
  26.   Version = '1.3';
  27.  
  28. Type
  29.   THost = object(TBBS)
  30.     Password   : String[20];
  31.     ChatReason : String[40];
  32.     InChat     : Boolean;
  33.     PromptSt   : String[80];
  34.  
  35.     CONSTRUCTOR Init;
  36.     PROCEDURE Run; VIRTUAL;
  37.     DESTRUCTOR Done; VIRTUAL;
  38.     FUNCTION Chat : Boolean;
  39.     FUNCTION HandleVirtualKey(Code : Char) : Boolean; VIRTUAL;
  40.     PROCEDURE UserSession;
  41.     FUNCTION Menu : Boolean;
  42.     PROCEDURE ListFiles;
  43.     PROCEDURE ShowFile;
  44.     PROCEDURE Upload;
  45.     PROCEDURE Download;
  46.     PROCEDURE ChatRequest;
  47.   end;
  48.  
  49. Var
  50.   Host : THost;
  51.  
  52. {********************************************************************}
  53.  
  54.   {
  55.   *  PROCEDURE GetScreenStr
  56.   *
  57.   *  Gets a string of text (no attributes) from the screen and stores
  58.   *  it in Strn.
  59.   }
  60.  
  61. PROCEDURE GetScreenStr(X, Y, Len : Byte; var Strn : String);
  62.  Var
  63.    Idx  : Byte;
  64.    Ch   : Char;
  65.    Attr : Byte;
  66.  
  67.  begin
  68.    Strn := '';
  69.    for Idx := X to X + Len - 1 do
  70.     begin
  71.       GetScreenWord(Idx, Y, Ch, Attr);
  72.       Strn := Strn + Ch;
  73.     end;
  74.  end;
  75.  
  76. {--------------------------------------------------------------------}
  77.  
  78. PROCEDURE Usage;
  79.  begin
  80.    WriteLn;
  81.    WriteLn('Host usage:');
  82.    WriteLn;
  83.    WriteLn('HOST <comport> <baudrate>');
  84.    WriteLn;
  85.    WriteLn(' <comport> can be 1, 2, 3 or 4.');
  86.    WriteLn(' <baudrate> can be 300, 1200, 2400, 4800, 9600, 19200 or 38400.');
  87.    WriteLn;
  88.    WriteLn('example: HOST 2 2400    { com2, at 2400bps }');
  89.    WriteLn('         HOST 1 9600    { com1, at 9600bps }');
  90.  end;
  91.  
  92. {--------------------------------------------------------------------}
  93.  
  94. CONSTRUCTOR THost.Init;
  95.  Var
  96.    Ch : Char;
  97.  
  98.  begin
  99.    TBBS.Init;
  100.    if (not Exist('FILES')) then
  101.     begin
  102.       vcWriteLn('');
  103.       vcWriteLn('Subdirectory "FILES" not found.');
  104.       vcWriteLn('');
  105.       vcWrite('Create or quit program? (C/Q): ');
  106.       Repeat
  107.         Ch := UpCase(ReadKey);
  108.       Until (Ch = 'C') or (Ch = 'Q');
  109.       if (Ch = 'C') then
  110.        begin
  111.          vcWriteLn('Create');
  112.          MkDir('FILES');
  113.        end
  114.       else
  115.        begin
  116.          vcWriteLn('Quit');
  117.          Halt(1);
  118.        end;
  119.     end;
  120.    OpenPort(StrToInt(ParamStr(1)));
  121.    SetAnswerMode(Answer);
  122.    SetOutput(True, False);
  123.    SetInput(True, False);
  124.    SetFlowControl(PortIdx, True, False);
  125.    ClearIntChars;
  126.    AddIntChar(' ');
  127.    SetVirtualKeys(True);
  128.    ClearVirtualKeys;
  129.    AddVirtualKey(#46);  { alt-C, chat enter/exit }
  130.    vcWriteLn('');
  131.    vcWrite('Today''s password: ');
  132.    ComReadLn(Password, 20);
  133.    Password := Upper(Password);
  134.    ChatReason := '';
  135.    InChat := False;
  136.  end;
  137.  
  138. {--------------------------------------------------------------------}
  139.  
  140. PROCEDURE THost.Run;
  141.  Var
  142.    Quit   : Boolean;
  143.    Result : String;
  144.  
  145.  begin
  146.    Quit := False;
  147.    ClrScr;
  148.    while (not Quit) do
  149.     begin
  150.       SetBpsRate(PortIdx, StrToInt(ParamStr(2)));
  151.       SendAT('ATZ');
  152.       vcWriteLn('');
  153.       vcWriteLn('Host: Waiting For Call   [SPC] for local login   [Q] to quit');
  154.       while (not LineRinging(PortIdx)) and (not Keypressed) do ;
  155.       if (Keypressed) then
  156.        begin
  157.          case UpCase(ReadKey) of
  158.            ' ' : begin
  159.                    SetInput(True, False);
  160.                    SetOutput(True, False);
  161.                    UserSession;
  162.                  end;
  163.            'Q' : Quit := True;
  164.          end;
  165.        end
  166.       else
  167.        begin
  168.          PickupPhone;
  169.          SetOutput(True, True);
  170.          SetInput(True, True);
  171.          ComReadLn(Result, 40);  { gobble inital CR }
  172.          ComReadLn(Result, 40);  { gobble result string }
  173.          if (Carrier(PortIdx)) then
  174.             UserSession;
  175.        end;
  176.     end;
  177.  end;
  178.  
  179. {--------------------------------------------------------------------}
  180.  
  181. DESTRUCTOR THost.Done;
  182.  begin
  183.    ClosePort(True);
  184.    TBBS.Done;
  185.  end;
  186.  
  187. {--------------------------------------------------------------------}
  188.  
  189. FUNCTION THost.Chat : Boolean;  { chat with user }
  190.  Var
  191.    St       : String;
  192.    Wrap     : String;
  193.  
  194.  begin
  195.    if (not InChat) then
  196.     begin
  197.       InChat := True;
  198.       ChatReason := '';
  199.       PromptSt := '';
  200.       GetScreenStr(1, WhereY, WhereX - 1, PromptSt);
  201.       ComWriteLn('');
  202.       ComWriteLn('');
  203.       ComWrite('Sysop has entered chat mode.');
  204.       vcWrite('  (Sysop: Alt-C to exit)');
  205.       ComWriteLn('');
  206.       ComWriteLn('');
  207.       Wrap := '';
  208.       while (InChat) do
  209.          ComReadLnWrap(St, 79, Wrap);
  210.       Chat := False;
  211.     end
  212.    else
  213.     begin
  214.       InChat := False;
  215.       ComWriteLn('');
  216.       ComWriteLn('');
  217.       ComWriteLn('Sysop has exited chat mode.');
  218.       ComWriteLn('');
  219.       ComWrite(PromptSt);
  220.       Chat := True;
  221.     end;
  222.  end;
  223.  
  224. {--------------------------------------------------------------------}
  225.  
  226. FUNCTION THost.HandleVirtualKey(Code : Char) : Boolean;
  227.  begin
  228.    case Code of
  229.      #46 : HandleVirtualKey := Chat;
  230.    end;
  231.  end;
  232.  
  233. {--------------------------------------------------------------------}
  234.  
  235. PROCEDURE THost.UserSession;
  236.  Var
  237.    Pass : String[20];
  238.    Try  : Byte;
  239.  
  240.  begin
  241.    SetLF(True);
  242.    ComWriteLn('');
  243.    ComWriteLn('BBSkit Host v' + Version);
  244.    Try := 0;
  245.    Pass := '';
  246.    while (Try < 4) and (Pass <> Password) do
  247.     begin
  248.       Inc(Try);
  249.       ComWriteLn('');
  250.       ComWrite('Password: ');
  251.       SetEcho('*');
  252.       ComReadLn(Pass, 20);
  253.       SetEcho(#0);
  254.       Pass := Upper(Pass);
  255.       ComWriteLn('');
  256.       if (Pass <> Password) then ComWriteLn('Incorrect.');
  257.     end;
  258.    if (Pass = Password) then
  259.     begin
  260.       ComWriteLn('');
  261.       ComWriteLn('Welcome to BBSkit Host.');
  262.       ComWriteLn('');
  263.       while (Menu) do ;
  264.     end;
  265.    Hangup;
  266.  end;
  267.  
  268. {--------------------------------------------------------------------}
  269.  
  270. FUNCTION THost.Menu : Boolean;
  271.  Var
  272.    Cmd : Char;
  273.  
  274.  begin
  275.    Menu := True;
  276.    vcWrite('Sysop: Alt-C enters chat mode');
  277.    if (ChatReason <> '') then
  278.       vcWrite('   WANTS CHAT: ' + ChatReason);
  279.    vcWriteLn('');
  280.    ComWrite('[L]ist files  [T]ype file  [U]pload  [D]ownload  [C]hat  [G]oodbye: ');
  281.    Cmd := UpCase(ComReadKey);
  282.    ComWriteLn(Cmd);
  283.    case Cmd of
  284.      'L' : ListFiles;
  285.      'T' : ShowFile;
  286.      'U' : Upload;
  287.      'D' : Download;
  288.      'C' : ChatRequest;
  289.      'G' : begin
  290.              ComWriteLn('');
  291.              ComWrite('Sure? ');
  292.              Repeat
  293.                Cmd := UpCase(ComReadKey);
  294.              Until (Cmd = 'Y') or (Cmd = 'N');
  295.              ComWriteLn(Cmd);
  296.              if (Cmd = 'Y') then
  297.               begin
  298.                 Menu := False;
  299.                 ComWriteLn('');
  300.                 ComWriteLn('Goodbye...');
  301.               end;
  302.              ComWriteLn('');
  303.            end;
  304.    end;
  305.  end;
  306.  
  307. {--------------------------------------------------------------------}
  308.  
  309. PROCEDURE THost.ListFiles;
  310.  Var
  311.    FInfo : SearchRec;
  312.    FTime : DateTime;
  313.    Name  : String[8];
  314.    Ext   : String[3];
  315.  
  316.  begin
  317.    ComWriteLn('');
  318.    ComWriteLn('Listing of all available files:');
  319.    ComWriteLn('');
  320.    FindFirst('FILES\*.*', Archive OR ReadOnly, FInfo);
  321.    while (DOSError = 0) do
  322.     begin
  323.       Name := Copy(FInfo.Name, 1, Pos('.', FInfo.Name) - 1);
  324.       Ext := Copy(FInfo.Name, Pos('.', FInfo.Name) + 1, 3);
  325.       UnpackTime(FInfo.Time, FTime);
  326.       ComWrite(Left(Name, 8) + '.' + Left(Ext, 3) + '    ');
  327.       ComWrite(Right(IntToStr(FInfo.Size), 7) + ' bytes    ');
  328.       if (FTime.Hour < 10) then ComWrite('0');
  329.       ComWrite(IntToStr(FTime.Hour) + ':');
  330.       if (FTime.Min < 10) then ComWrite('0');
  331.       ComWriteLn(IntToStr(FTime.Min));
  332.       FindNext(FInfo);
  333.     end;
  334.    ComWriteLn('');
  335.  end;
  336.  
  337. {--------------------------------------------------------------------}
  338.  
  339. PROCEDURE THost.ShowFile;
  340.  Var
  341.    Fname : String[12];
  342.  
  343.  begin
  344.    ComWriteLn('');
  345.    ComWrite('Filename: ');
  346.    ComReadLn(Fname, 12);
  347.    ComWriteLn('');
  348.    if (not Exist('FILES\' + Fname)) then
  349.       ComWriteLn('Could not find file.')
  350.    else
  351.     begin
  352.       ComWriteLn('Press SPACE to abort, ^S to pause (^Q restarts).');
  353.       ComWriteLn('');
  354.       TypeFile('FILES\' + Fname);
  355.     end;
  356.    ComWriteLn('');
  357.  end;
  358.  
  359. {--------------------------------------------------------------------}
  360.  
  361. PROCEDURE THost.Download;
  362.  Var
  363.    Ch    : Char;
  364.    Fname : String;
  365.    Good  : TError;
  366.    Match : Byte;
  367.    FInfo : SearchRec;
  368.  
  369.  begin
  370.    ComWriteLn('');
  371. {$IFNDEF DEMO}
  372.    ComWriteLn('Send mode: [X]modem, Xmodem-[C]RC, Xmodem-[1]K,');
  373.    ComWrite('           [Y]modem, Ymodem-[G]? ');
  374. {$ELSE}
  375.    ComWrite('Send mode: [X]modem, Xmodem-[C]RC, Xmodem-[1]K? ');
  376. {$ENDIF}
  377.    Ch := UpCase(ComReadKey);
  378.    ComWriteLn(Ch);
  379. {$IFNDEF DEMO}
  380.    if (Pos(Ch, 'XC1YG') > 0) then
  381. {$ELSE}
  382.    if (Pos(Ch, 'XC1') > 0) then
  383. {$ENDIF}
  384.     begin
  385.       case Ch of
  386.         'X',
  387.         'C',
  388.         '1' : begin
  389.                 ComWriteLn('');
  390.                 ComWrite('File: ');
  391.                 ComReadLn(Fname, 12);
  392.                 if (Fname <> '') then
  393.                  begin
  394.                    ComWriteLn('');
  395.                    ComWriteLn('Begin receiving now, or press ^X several times to abort.');
  396.                    Fname := 'FILES\' + Fname;
  397.                    case Ch of
  398.                      'X' : Good := SendXmodem(Checksum, Fname);
  399.                      'C' : Good := SendXmodem(CRC, Fname);
  400.                      '1' : Good := SendXmodem(OneK, Fname);
  401.                    end;
  402.                  end;
  403.               end;
  404. {$IFNDEF DEMO}
  405.         'Y',
  406.         'G' : begin
  407.                 ComWriteLn('');
  408.                 ComWriteLn('Batch download: enter each file on a line by itself. A blank line');
  409.                 ComWriteLn('exits batch entry.');
  410.                 ComWriteLn('');
  411.                 ClearBatch;
  412.                 Repeat
  413.                   ComReadLn(Fname, 12);
  414.                   if (Fname <> '') then
  415.                      AddBatch('FILES\' + Fname);
  416.                 Until (Fname = '');
  417.                 if (FilesInBatch > 0) then
  418.                  begin
  419.                    ComWriteLn('');
  420.                    ComWriteLn('Begin receiving now, or press ^X several times to abort.');
  421.                    case Ch of
  422.                      'Y' : Good := SendYmodem(Normal);
  423.                      'G' : Good := SendYmodem(Streaming);
  424.                    end;
  425.                  end;
  426.               end;
  427. {$ENDIF}
  428.       end;
  429.       ComWriteLn('');
  430.       ComWriteLn('');
  431.       if (Good = NoError) then ComWriteLn('Transfer was successful.')
  432.       else ComWriteLn('Transfer failed.');
  433.     end;
  434.  end;
  435.  
  436. {--------------------------------------------------------------------}
  437.  
  438. PROCEDURE THost.Upload;
  439.  Var
  440.    Ch    : Char;
  441.    Dir   : String;
  442.    Fname : String;
  443.    Ext   : String;
  444.    Good  : TError;
  445.    F     : Text;
  446.    Index : Byte;
  447.  
  448.  begin
  449.    ComWriteLn('');
  450. {$IFNDEF DEMO}
  451.    ComWriteLn('Receive mode: [X]modem, Xmodem-[C]RC, Xmodem-[1]K,');
  452.    ComWrite('              [Y]modem, Ymodem-[G]? ');
  453. {$ELSE}
  454.    ComWrite('Receive mode: [X]modem, Xmodem-[C]RC, Xmodem-[1]K? ');
  455. {$ENDIF}
  456.    Ch := UpCase(ComReadKey);
  457.    ComWriteLn(Ch);
  458. {$IFNDEF DEMO}
  459.    if (Pos(Ch, 'XC1YG') > 0) then
  460. {$ELSE}
  461.    if (Pos(Ch, 'XC1') > 0) then
  462. {$ENDIF}
  463.     begin
  464.       case Ch of
  465.         'X',
  466.         'C',
  467.         '1' : begin
  468.                 ComWriteLn('');
  469.                 ComWrite('File to receive: ');
  470.                 ComReadLn(Fname, 12);
  471.                 if (not Exist('FILES\' + Fname)) then
  472.                  begin
  473.                    ComWriteLn('');
  474.                    ComWriteLn('Begin upload now, or press ^X several times to abort.');
  475.                    case Ch of
  476.                      'X' : Good := ReceiveXmodem(Checksum, 'FILES\' + Fname);
  477.                      'C' : Good := ReceiveXmodem(CRC, 'FILES\' + Fname);
  478.                      '1' : Good := ReceiveXmodem(OneK, 'FILES\' + Fname);
  479.                    end;
  480.                  end
  481.                 else
  482.                  begin
  483.                    ComWriteLn('');
  484.                    ComWriteLn('File already exists!');
  485.                    Good := NoError;
  486.                  end;
  487.               end;
  488. {$IFNDEF DEMO}
  489.         'Y',
  490.         'G' : begin
  491.                 ComWriteLn('');
  492.                 ComWriteLn('Begin batch upload now, or press ^X several times to abort.');
  493.                 case Ch of
  494.                   'Y' : Good := ReceiveYmodem(Normal, 'FILES\');
  495.                   'G' : Good := ReceiveYmodem(Streaming, 'FILES\');
  496.                 end;
  497.               end;
  498. {$ENDIF}
  499.       end;
  500.       ComWriteLn('');
  501.       ComWriteLn('');
  502.       if (Good = NoError) then ComWriteLn('Transfer was successful.')
  503.       else
  504.        begin
  505.          ComWriteLn('Transfer failed.');
  506.          if (Pos(Ch, 'XC1') <> 0) then
  507.           begin
  508.             if (Exist('FILES\' + Fname)) then
  509.              begin
  510.                Assign(F, 'FILES\' + Fname);
  511.                Erase(F);
  512.              end;
  513. {$IFNDEF DEMO}
  514.           end
  515.          else
  516.           begin
  517.             Fname := BatchFile(FilesInBatch);
  518.             if (Exist(Fname)) then
  519.              begin
  520.                Assign(F, Fname);
  521.                Erase(F);
  522.              end;
  523.             if (FilesInBatch > 1) then
  524.              begin
  525.                ComWriteLn('');
  526.                if (FilesInBatch = 2) then
  527.                   ComWriteLn('The following file was received successfully:')
  528.                else
  529.                   ComWriteLn('The following files were received successfully:');
  530.                ComWriteLn('');
  531.                for Index := 1 to FilesInBatch - 1 do
  532.                 begin
  533.                   FSplit(BatchFile(Index), Dir, Fname, Ext);
  534.                   ComWriteLn(Fname + Ext);
  535.                 end;
  536.              end;
  537. {$ENDIF}
  538.           end;
  539.        end;
  540.     end;
  541.  end;
  542.  
  543. {--------------------------------------------------------------------}
  544.  
  545. PROCEDURE THost.ChatRequest;
  546.  begin
  547.    ComWriteLn('');
  548.    ComWrite('Reason for chat: ');
  549.    ComReadLn(ChatReason, 40);
  550.  end;
  551.  
  552. {********************************************************************}
  553.  
  554. BEGIN
  555.   if (ParamCount <> 2) then Usage
  556.   else
  557.    begin
  558.      Host.Init;
  559.      Host.Run;
  560.      Host.Done;
  561.    end;
  562. END.
  563.  
  564.